home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 January - Disc 2 / Macworld (1999-01) (Disk 2).dmg / Serious Demos / Symbolic Composer 4.2 / Environment / Projects / Examples / Demos / Endless < prev    next >
Lisp/Scheme  |  1998-10-26  |  3KB  |  106 lines
  1. ; by Peter Stone after JS.Bach SCOM-retranscription by Janusz Podrazik
  2. ; to analyze the score double-click high-lighted keywords
  3.  
  4. (def-orchestra 'orchestra
  5.    all-instr (piano bass clarinet)
  6. )
  7.  
  8. (setq zones 32)
  9.  
  10. (defun make-velocity-zones (velpat vector)
  11.   (let (collect)
  12.     (dolist (x (vector-to-list vector))
  13.       (push (reposition-integer-list velpat x) collect))
  14.     (nreverse collect)))
  15.  
  16. (defun reposition-integer-list (pat pos)
  17.   (let ((gap (- pos (car pat))))
  18.     (mapcar #'(lambda (x) (+ x gap)) pat)))
  19.  
  20. (setq velocity-curve
  21.   (vector-round 34 64 (vector-resynthesize 3 (gen-noise-white zones 1 0.123) nil t)))
  22.  
  23. (setq velocity-lh
  24.       (make-velocity-zones '(0 -5 10) velocity-curve))
  25.  
  26. (setq velocity-rh1
  27.       (make-velocity-zones '(0) velocity-curve))
  28.  
  29. (setq velocity-rh2
  30.       (make-velocity-zones '(0 -5) velocity-curve))
  31.  
  32. (def-grammar 'mel
  33.    a (a b d)
  34.    b (d a)
  35.    d (b c a)
  36. )
  37.  
  38. (def-section-timesheet sect-a
  39.    ;
  40.    ; zones and tonalities
  41.    ;
  42.    with 1/1
  43.    ;           !---!---!---!---!---!---!---!---!
  44.    tonality   "................" (fold-tonality 'b 4 
  45.                                     (symbols-to-tonality
  46.                                      symbols (gen-trans b 2 'mel)
  47.                                      transpose '((0 2 4) (2 4 0) (4 0 2))
  48.                                      mapping (activate-tonality (harmonic-minor c 4))))
  49.    all-instr  "----------------" 
  50.    ;
  51.    ; rhythmics, melodies and velocities
  52.    ;
  53.    beat 1/16 ; !---!---!---!---!
  54.    legato 90
  55.    piano      "  ------  ------" (match-beat '(a b c d b e c d c b)) with velocity-lh
  56.    bass       " -       -      " (mapcar #'(lambda (x) (list x))
  57.                                          (gen-trans a 2 'mel)) with velocity-rh1
  58.    clarinet   "-       -       " (mapcar #'(lambda (x) (list x))
  59.                                          (gen-trans b 2 'mel)) with velocity-rh2
  60. )
  61.  
  62. (def-section sect-a
  63.    default
  64.       tempo-zones (gen-repeat 16 '(1/1))
  65.       tempo       (vector-to-list 
  66.                     (vector-scale 61 58 
  67.                       (vector-resynthesize 2 
  68.                         (gen-noise-white zones 1 0.123) nil t)))
  69.    piano
  70.       channel 1
  71.    bass
  72.       channel 2
  73.    clarinet
  74.       channel 3
  75. )
  76.  
  77. (clone-section sect-a sect-b)
  78.  
  79. (def-section-timesheet sect-b
  80.    ;
  81.    ; zones and tonalities
  82.    ;
  83.    with 1/1
  84.    ;           !---!---!---!---!---!---!---!---!
  85.    tonality   "................" (fold-tonality 'b 4 
  86.                                     (symbols-to-tonality
  87.                                      symbols (reverse (gen-trans b 2 'mel))
  88.                                      transpose '((0 2 4) (2 4 0) (4 0 2))
  89.                                      mapping (activate-tonality (pentatonic c 4))))
  90.    all-instr  "----------------" 
  91.    ;
  92.    ; rhythmics, melodies and velocities
  93.    ;
  94.    beat 1/16 ; !---!---!---!---!
  95.    legato 90
  96.    piano      "  ------  ------" (match-beat '(a b c d b e c d c b)) with velocity-lh
  97.    bass       " -       -      " (mapcar #'(lambda (x) (list x))
  98.                                          (gen-trans a 2 'mel)) with velocity-rh1
  99.    clarinet   "-       -       " (mapcar #'(lambda (x) (list x))
  100.                                          (gen-trans b 2 'mel)) with velocity-rh2
  101. )
  102.  
  103. (play-file-p "Endless midi"
  104.    all-instr '(sect-a sect-b)
  105. )
  106.